home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / dbase / lib19.zip / MISC.PRG < prev    next >
Encoding:
Text File  |  1992-09-09  |  35.8 KB  |  995 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: MISC.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: These are the miscellaneous functions/procedures from the PROC
  6. *--             file that aren't as commonly used as the others. See README.TXT
  7. *--             for details on how to use this library file.
  8. *--             The following functions have been copied from the appropriate
  9. *--             library files, and may be deleted if this program is simply
  10. *--             copied into the PROC.PRG file with STRINGS.PRG and CONVERT.PRG
  11. *--             files:
  12. *--             ATCOUNT() (from STRINGS.PRG)
  13. *--             DEC2HEX() (from CONVERT.PRG)
  14. *--             STRPBRK() (from STRINGS.PRG)
  15. *-------------------------------------------------------------------------------
  16.  
  17. FUNCTION PlayIt
  18. *-------------------------------------------------------------------------------
  19. *-- Programmer..: Mike Carlisle (A-T)
  20. *-- Date........: 01/21/1992
  21. *-- Notes.......: This function (from Technotes, issue??) will play a song
  22. *--               stored in a memory variable (array).
  23. *--               This is a two dimensional array, with the first dimension
  24. *--               defined being the # of notes, each note having two parts.
  25. *--               For a song with 12 notes, the declare statement is:
  26. *--                 DECLARE aSong[12,2]
  27. *--               aSong[1,1] is the pitch of the first note.
  28. *--               aSong[1,2] is the duration of the first note.
  29. *--               Pitches are defined from C below Middle C to B below Middle C.
  30. *--               These are from a "tempered" scale. Values can be raised an
  31. *--               octave by doubling the number, lowered by halving it.
  32. *--               Duration can be from 1 to 20.
  33. *--                           Note   Value
  34. *--                           C      261
  35. *--                           C#     277
  36. *--                           D      294
  37. *--                           D#     311
  38. *--                           E      329
  39. *--                           F      349
  40. *--                           F#     370
  41. *--                           G      392
  42. *--                           G#     415
  43. *--                           A      440
  44. *--                           A#     466
  45. *--                           B      494
  46. *-- Written for.: dBASE IV, 1.1
  47. *-- Rev. History: 01/21/1992 - Modified to allow use of parameter to choose
  48. *--               the song to be played. This alleviates the need for the
  49. *--               procedures SONG1 and SONG2 and the memfile created by them.
  50. *--               Two songs are provided (see below) ...
  51. *-- Calls.......: None
  52. *-- Called by...: Any
  53. *-- Usage.......: PlayIt(<nSong>)
  54. *-- Example.....: @5,10 say "Enter last name: " get lName valid required
  55. *--                      .not. empty(lName);
  56. *--                      error PlayIt(1)+"There must be a lastname ..."
  57. *--               Read
  58. *--                 && OR
  59. *--               ?? PlayIt(2)
  60. *-- Returns.....: Nul (or Beep on invalid parameter)
  61. *-- Parameters..: nSong = Song number. Programmer might consider adding to the
  62. *--                       list below for any songs added for documentation
  63. *--                       purposes ...
  64. *--                       VALID VALUES/SONGS:
  65. *--                         1  =  Dirge
  66. *--                         2  =  "Touchdown"
  67. *-------------------------------------------------------------------------------
  68.  
  69.     parameter nSong
  70.     private aSong, nCounter
  71.     
  72.     *-- check for valid type of parameter ... must be numeric ...
  73.     if .not. type("nSong") $ "NF"
  74.         return chr(7)
  75.     endif
  76.     
  77.     *-- get the integer value of nSong ... in case someone tries a "fast one"
  78.     nSong = int(nSong)
  79.     
  80.     *-- load song
  81.     do case
  82.         case nSong = 1  && dirge
  83.             declare aSong[12,2]          && 12 notes, 2 parts each
  84.             store 220     to aSong[1,1]  && pitch
  85.             store  10     to aSong[1,2]  && duration
  86.             store 220     to aSong[2,1]
  87.             store  10     to aSong[2,2]
  88.             store 220     to aSong[3,1]
  89.             store   2     to aSong[3,2]
  90.             store 220     to aSong[4,1]
  91.             store  10     to aSong[4,2]
  92.             store 261.63  to aSong[5,1]
  93.             store   7     to aSong[5,2]
  94.             store 246.94  to aSong[6,1]
  95.             store   2     to aSong[6,2]
  96.             store 246.94  to aSong[7,1]
  97.             store   5     to aSong[7,2]
  98.             store 220     to aSong[8,1]
  99.             store   5     to aSong[8,2]
  100.             store 220     to aSong[9,1]
  101.             store   5     to aSong[9,2]
  102.             store 205     to aSong[10,1]
  103.             store   5     to aSong[10,2]
  104.             store 220     to aSong[11,1]
  105.             store  15     to aSong[11,2]
  106.         case nSong = 2  && "touchdown"
  107.             declare aSong[7,2]           && 7 notes, 2 parts each
  108.             store 523.5   to aSong[1,1]  && pitch
  109.             store   2     to aSong[1,2]  && duration
  110.             store 587.33  to aSong[2,1]
  111.             store   2     to aSong[2,2]
  112.             store 659.29  to aSong[3,1]
  113.             store   2     to aSong[3,2]
  114.             store 783.99  to aSong[4,1]
  115.             store   7     to aSong[4,2]
  116.             store 659.29  to aSong[5,1]
  117.             store   2     to aSong[5,2]
  118.             store 783.99  to aSong[6,1]
  119.             store  10     to aSong[6,2]
  120.         otherwise                       && not song 1 or 2, return nothing
  121.             return chr(7)
  122.     endcase
  123.     
  124.     *-- playback
  125.     nCounter = 1
  126.     do while type("aSong[nCounter,1]") = "N"
  127.         set bell to aSong[nCounter,1],aSong[nCounter,2]
  128.         ?? chr(7) at col()
  129.         nCounter = nCounter + 1
  130.     enddo
  131.     set bell to  && return value to original
  132.  
  133. RETURN ""
  134. *-- EoF: PlayIt()
  135.  
  136. PROCEDURE PageEst
  137. *-------------------------------------------------------------------------------
  138. *-- Programmer..: Rachel Holmen (RAEHOLMEN)
  139. *-- Date........: 02/04/1992
  140. *-- Notes.......: This procedure estimates the number of pages needed for an 
  141. *--                output list. 
  142. *-- Written for.: dBASE IV, 1.1
  143. *-- Rev. History: 01/15/1992 - original procedure.
  144. *--               02/04/1992 - Ken Mayer - overhaul to allow the sending of
  145. *--               parameters for fields, rather than hard coding. Attempted to
  146. *--               make this a "black box" procedure.
  147. *-- Calls.......: CENTER               Procedure in PROC.PRG
  148. *--               SHADOW               Procedure in PROC.PRG
  149. *-- Called by...: Any
  150. *-- Usage.......: Do PageEst with <nCount>,"<cReport>",<nRecords>
  151. *-- Example.....: Use printers
  152. *--               Do PageEst with 0,"Printer for 'Hew' $ Brand",55
  153. *-- Returns.....: None
  154. *-- Parameters..: nCount   = record count for records to be printed ...
  155. *--                          if sent as "0", system will do a RECCOUNT() for you
  156. *--               cReport  = name of report, with any filters ... (FOR ...)
  157. *--               nRecords = number of records per page the report will handle.
  158. *--                          if sent as "0", system will assume 60 ...
  159. *-------------------------------------------------------------------------------
  160.  
  161.     parameters nCount,cReport,nRecords
  162.     private cReport2,nPos,nPage,cPage,cChoice,cCursor
  163.     
  164.     cReport2 = upper(cReport)
  165.     
  166.     *-- make sure we have a number of records to work with ...
  167.     if nCount = 0
  168.         if at("FOR",cReport2) > 0     && if a filter, extract the filter
  169.             npos = at("FOR",cReport2)  && so we can count records that match
  170.             cFilter = substr(cReport,Pos+3,len(cReport)-(npos-1))
  171.             count to nCount for &cFilter
  172.         else
  173.             nCount = reccount()
  174.         endif
  175.     endif
  176.     
  177.     if nRecords = 0
  178.         nRecords = 60
  179.     endif
  180.     
  181.     *-- calculate the number of pages for the report ...
  182.     store int(nCount/nRecords) to nPage
  183.     if mod(nCount,nRecords) > 45
  184.         store nPage+1 to nPage
  185.     else
  186.        store (nCount/nRecords) to nPage
  187.     endif
  188.     if nCount>0 .and. nCount < nRecords
  189.        store 1 to nPage
  190.     endif
  191.     
  192.     *-- deal with displaying info, and printing the report ...
  193.     save screen to sPrinter
  194.     activate screen            && in case there are other windows on screen ...
  195.     define window wPrinter from 8,15 to 15,65 double color rg+/gb,w/n,rg+/gb
  196.     do shadow with 8,15,15,65
  197.     activate window wPrinter
  198.     
  199.     *-- figure out how much to tell the user ...
  200.     if mod(nCount,nRecords) > 19 .and. mod(nCount,nRecords) < 46
  201.        store ltrim(str(nPage))+" and a half pages.)" to cPage
  202.     else
  203.        store ltrim(str(nPage))+" pages.)" to cPage
  204.     endif
  205.     
  206.     if nPage = 1
  207.        store "one page.)" to cPage
  208.     endif
  209.     
  210.     *-- display info ...
  211.     do center with 1,50,"",;
  212.         "There are "+ltrim(str(nCount))+" records."
  213.     do center with 2,50,"","(That's approximately "+cPage
  214.     
  215.     *-- ask if they want to generate the report?
  216.     store space(1) to cChoice
  217.     @4,8 say "Do you want to print the list? " get cChoice picture "!" ;
  218.         valid required cChoice $ "YN";
  219.         error chr(7)+"Enter 'Y' or 'N'!"
  220.     read
  221.     
  222.     *-- if yes, do it ...
  223.     if cChoice = "Y"
  224.         clear   && just this window ...
  225.         do center with 2,50,"","Align paper in your printer."
  226.         do center with 3,50,"","Press any key to continue ..."
  227.         x=inkey(0)
  228.         clear
  229.         do center with 2,50,"","... Printing ... do not disturb ..."
  230.         cCursor = set("CURSOR")
  231.         set cursor off
  232.         set console off
  233.         report form &cReport to print
  234.         set console on
  235.         set cursor &cCursor
  236.     endif
  237.     
  238.     *-- cleanup
  239.     deactivate window wPrinter
  240.     release window wPrinter
  241.     restore screen from sPrinter
  242.     release screen sPrinter
  243.  
  244. RETURN
  245. *-- EoP: PageEst
  246.  
  247. FUNCTION Permutes
  248. *-------------------------------------------------------------------------------
  249. *-- Programmer..: Jay Parsons (JPARSONS)
  250. *-- Date........: 03/01/1992
  251. *-- Notes.......: Permutations of nNum items taken Nhowmany at a time
  252. *--               That is, the number of possible arrangements, as
  253. *--               the different ways a president, V.P. and sec'y may
  254. *--               be chosen from a club of 10 members
  255. *-- Written for.: dBASE IV, 1.1
  256. *-- Rev. History: None
  257. *-- Calls.......: None
  258. *-- Called by...: Any
  259. *-- Usage.......: Permutes(<nNum>,<nHowMany>)
  260. *-- Example.....: ?Permutes(10,3)
  261. *-- Returns.....: Numeric
  262. *-- Parameters..: nNum     = number of items in the entire set
  263. *--               nHowMany = number to be used at once
  264. *-------------------------------------------------------------------------------
  265.  
  266.     parameters nNum, nHowmany
  267.     private nResult, nCounter
  268.     store 1 to nResult, nCounter
  269.     do while nCounter <= nHowmany
  270.       nResult = nResult * ( nNum + 1 - nCounter )
  271.       nCounter = nCounter + 1
  272.     enddo
  273.     
  274. RETURN nResult
  275. *-- EoF: Permutes()
  276.  
  277. FUNCTION Combos
  278. *-------------------------------------------------------------------------------
  279. *-- Programmer..: Jay Parsons (JPARSONS)
  280. *-- Date........: 03/01/1992
  281. *-- Notes.......: Combinations, similar to Permutations
  282. *--               Combinations treat "1, 3" as the same as
  283. *--               "3, 1", unlike permutations.  This gives the
  284. *--               games needed for a round robin and helps with
  285. *--               figuring odds of most state lotteries.
  286. *-- Written for.: dBASE IV, 1.1
  287. *-- Rev. History: None
  288. *-- Calls.......: None
  289. *-- Called by...: Any
  290. *-- Usage.......: Combos(<nNum>,<nHowMany>)
  291. *-- Example.....: ?Combos(10,2)
  292. *-- Returns.....: Numeric
  293. *-- Parameters..: nNum     = number of items in the entire set
  294. *--               nHowMany = number to be used at once
  295. *-------------------------------------------------------------------------------
  296.  
  297.     parameters nNum, nHowmany
  298.     private nResult, nCounter
  299.     store 1 to nResult, nCounter
  300.     do while nCounter <= nHowmany
  301.       nResult = nResult * ( nNum + 1 - nCounter ) / nCounter
  302.       nCounter = nCounter + 1
  303.     enddo
  304.     
  305. RETURN nResult
  306. *-- Combos()
  307.                                                           
  308. FUNCTION BinLoad
  309. *-------------------------------------------------------------------------------
  310. *-- Programmer..: Jay Parsons (JPARSONS)
  311. *-- Date........: 03/01/1992
  312. *-- Notes.......: Function to manage .bin files
  313. *--               A call to this function results in the following actions:
  314. *--          
  315. *--               If the name of a binary module alone is given as the argument,
  316. *--               the module is loaded if necessary, and .T. is returned.
  317. *--               If the file cannot be found, returns .F.
  318. *--               An error occurring during the load will cause a dBASE error.
  319. *--
  320. *--               If the argument "" is given, RELEASES all loaded modules and
  321. *--               returns .T.
  322. *--
  323. *--               If the argument contains the name of a loaded binary file
  324. *--               and "/R", RELEASEs that file only and returns .T.  If the
  325. *--               file is not listed in "gc_bins_in", returns .F.
  326. *--
  327. *--               This function uses the public variable "gc_bins_in".  It
  328. *--               keeps track of the modules loaded by changing the contents
  329. *--               of that variable.  If modules are loaded or released without
  330. *--               the use of this function, the variable will contain an
  331. *--               inaccurate list of the modules loaded and problems will
  332. *--               almost surely occur if this function is used later.
  333. *--
  334. *--               If more than 16 binary modules are requested over time through
  335. *--               this function, the one that was named least recently in a call
  336. *--               to load it by this function is released to make room for the
  337. *--               new one.  This will not necessarily be the module last used,
  338. *--               unless care is taken to use this function to "reload" the
  339. *--               .bin before each call.
  340. *--
  341. *--               Suggested syntax, to call the binary routine "Smedley.bin" 
  342. *--               which takes and returns two arguments:
  343. *-- 
  344. *--               IF binload( "Smedley" )
  345. *--                 CALL Smedley WITH Arg1, Arg2
  346. *--               ELSE
  347. *--                 ? "binary file not available"
  348. *--               ENDIF
  349. *-- Written for.: dBASE IV, 1.1
  350. *-- Rev. History: None
  351. *-- Calls.......: ATCOUNT()            Function in MISC.PRG
  352. *-- Called by...: Any
  353. *-- Usage.......: BinLoad(<cBinName>)
  354. *-- Example.....: ?BinLoad("Smedley")
  355. *-- Returns.....: Logical (.T. if successful )
  356. *-- Parameters..: cBinName = name of bin file to load ...
  357. *-------------------------------------------------------------------------------
  358.  
  359.     parameters cBinname
  360.    private cBin, nPlace, nTemp, lResult
  361.     cBin = ltrim( trim( upper( cBinname ) ) )
  362.     if type( "gc_bins_in" ) = "U"
  363.        public gc_bins_in
  364.        gc_bins_in = ""
  365.     endif
  366.    lResult = .T.
  367.    do case
  368.        case "" = cBin
  369.            do while "" # gc_bins_in
  370.               nPlace = at( "*", gc_bins_in )
  371.               cBin = left( gc_bins_in, nPlace - 1 )
  372.               gc_bins_in = substr( gc_bins_in, nPlace + 1 )
  373.               release module &cBin
  374.            enddo
  375.            release gc_bins_in
  376.        case "/R" $ cBinname
  377.            cBin = trim( left( cBin, at( cBin, "/" ) - 1 ) )
  378.           if "." $ cBin
  379.              cBin = left( cBin, at( ".", cBin ) - 1 )
  380.           endif
  381.           nPlace = at( cBin, gc_bins_in )
  382.            if nPlace = 0
  383.              lResult = .F.
  384.           else
  385.              gc_bins_in = substr( gc_bins_in, nPlace + 1 )
  386.              release module &cBin
  387.           endif
  388.        otherwise
  389.           if "." $ cBin
  390.              cBin = left( cBin, at( ".", cBin ) - 1 )
  391.           endif
  392.           if .not. file( cBin )
  393.              lResult = .F.
  394.           else
  395.              if atcount( "*", gc_bins_in ) > 15
  396.                 nPlace = at( "*", gc_bins_in )
  397.                 cTemp = left( gc_bins_in, nPlace - 1 )
  398.                 release module &cTemp
  399.                 gc_bins_in = substr( gc_bins_in, nPlace + 1)
  400.              endif
  401.              load &cBin
  402.              nPlace = at( cBin, gc_bins_in )
  403.              if Place > 0
  404.                 gc_bins_in = stuff( gc_bins_in, nPlace, len( cBin ) + 1, "" )
  405.              endif
  406.              gc_bins_in = gc_bins_in + cBin + "*"
  407.           endif
  408.    endcase
  409.  
  410. RETURN lResult
  411. *-- EoF: BinLoad()
  412.  
  413. FUNCTION DialUp
  414. *-----------------------------------------------------------------------
  415. *-- Programmer..: Jay Parsons (JPARSONS)
  416. *-- Date........: 06/17/1992
  417. *-- Notes.......: Dial the supplied telephone number.  Returns .F. for error.
  418. *--               This is not a full communications routine.  It is designed
  419. *--               to be used to place voice telephone calls, with the user
  420. *--               picking up the handset after using this function to dial.
  421. *--
  422. *--               This will work only with a modem using the standard Hayes
  423. *--               commands, and only if the port has already been set to the
  424. *--               desired baud rate, etc., by the DOS MODE command or 
  425. *--               otherwise.  If the port and dialing method are not constant
  426. *--               for the application, rewrite the function to accept them as
  427. *--               additional parameters.
  428. *--
  429. *-- Written for.: dBASE IV, 1.1, 1.5
  430. *-- Rev. History: 03/01/1992 - original function.
  431. *--               04/01/1992 - Jay Parsons - modified for Version 1.5.
  432. *--               04/03/1992 - Jay Parsons - ferror() call added.
  433. *--               06/17/1992 - Jay Parsons - 1.1 version changed to use
  434. *--                              SET PRINTER TO Device rather than .bin.
  435. *-- Calls       : Strpbrk()            Function in MISC.PRG
  436. *-- Called by...: Any
  437. *-- Usage.......: DialUp(<cPhoneNo>)
  438. *-- Example.....: x = DialUp( "555-1212" )
  439. *-- Returns.....: Logical (connect made or not)
  440. *-- Parameters..: cPhoneNo = Phone number to dial ...
  441. *-- Side effects: When used for versions before 1.1, sets the printer to
  442. *--             : a COM port and does not reset it.
  443. *-----------------------------------------------------------------------
  444.  
  445.    parameters cPhoneNo
  446.    private cNumber, cPort, cDialtype, cCallarg, xTemp, nHandle,;
  447.               cString, lResult
  448.    cPort = "Com2"          && specify Com1 or Com2 as required 
  449.    cDialtype = "Tone"      && specify Tone or Pulse ( rotary ) dialing
  450.    cNumber = cPhoneno
  451.    if type( "cPhoneno" ) $ "NF"
  452.       cNumber = ltrim( str( cPhoneno ) )
  453.    else
  454.       do while .t.
  455.          xTemp = Strpbrk( cNumber, " ()-" )
  456.          if xTemp = 0
  457.             exit
  458.          endif
  459.          cNumber = stuff( cNumber, xTemp, 1, "" )
  460.       enddo
  461.    endif
  462.    cString = "ATD" + upper( left( cDialtype, 1 ) ) + cNumber + chr(13 )
  463.    if val( substr( version(), 9, 5 ) ) < 1.5
  464.       SET PRINTER TO &cPort
  465.       ??? Cstring
  466.       lResult = .T.
  467.    else
  468.       nHandle = fopen( cPort, "w" )
  469.       if ferror() # 0
  470.          RETURN .F.
  471.       endif
  472.       lResult = ( fwrite( nHandle, cString ) = len( cString ))
  473.       xTemp = fclose( nHandle )
  474.    endif
  475.  
  476. RETURN lResult
  477. *-- EoF: Dialup()
  478.  
  479. FUNCTION CurrPort
  480. *-------------------------------------------------------------------------------
  481. *-- Programmer..: David P. Brown (RHEEM)
  482. *-- Date........: 03/22/1992
  483. *-- Notes.......: This procedure gets the current SET PRINTER TO information.
  484. *--               Will return a port or a filename if set to a file. This also
  485. *--               requires a DBF file called CURRPRT.DBF, with an MDX tag
  486. *--               set on the only field CURRPRT, which is a character field
  487. *--               of 80 characters.
  488. *--
  489. *--               Structure for database: CURRPRT.DBF
  490. *--               Number of data records:       0
  491. *--               Date of last update   : 03/22/92
  492. *--               Field  Field Name  Type       Width    Dec    Index
  493. *--                   1  CURRPRT     Character     80               Y
  494. *--               ** Total **                      81
  495. *--
  496. *-- Written for.: dBASE IV, 1.1
  497. *-- Rev. History: 03/18/1992 - original function.
  498. *--               03/18/1992 -- Ken Mayer (KENMAYER) to clean it up a bit, and
  499. *--               make it a function (not requiring the public memvar that
  500. *--               was originally required).
  501. *--               03/21/1992 -- David P. Brown (RHEEM) found bug while
  502. *--               selecting a previous work area (stored on cDBF).  Changed
  503. *--               'select cDBF' to 'select (cDBF)'.
  504. *--               03/22/1992 -- David P. Brown (RHEEM) final revision.  Added
  505. *--               check for no available work areas.  If none is available
  506. *--               then the program returns a null.
  507. *-- Calls.......: None
  508. *-- Called by...: Any
  509. *-- Usage.......: CurrPort()
  510. *-- Example.....: ? CurrPort()
  511. *-- Returns.....: the current port, as a character value
  512. *--               Port:   LPTx:, COMx:, PRN:
  513. *--               File:   Filename (with or without drive and path, depends
  514. *--                       on how the user entered it in the SET command)
  515. *--               Other:  Null (no work area available)
  516. *-- Parameters..: None
  517. *-------------------------------------------------------------------------------
  518.  
  519.    private cSafety, cConsole, cDBF, cPort
  520.  
  521.    *-- Check for available work area (safety check)
  522.    if select() = 0
  523.       return ""
  524.    endif
  525.    *-- Setup
  526.    cSafety = set("SAFETY")
  527.    set safety off
  528.    *-- so user can't see what's going on
  529.    cConsole = set("CONSOLE")
  530.    set console off
  531.    
  532.    if file("CURRPRT$.OUT")  && if this file exists
  533.       erase CURRPRT$.OUT    &&   delete it, so we can write on it
  534.    endif
  535.    
  536.    cDBF = alias()           && get current work area, so we can return ...
  537.    
  538.    *-- Get current printer
  539.    *-- note that we are not using 'Set Printer to file ...' due to the
  540.    *-- fact that this will change the info that the 'LIST STAT' command
  541.    *-- issues ...
  542.    set alternate to currprt$.out  && direct screen input to file
  543.    set alternate on
  544.    list status                    && returns environment information
  545.    set alternate off              && turn off 'capture'
  546.    close alternate                && close file 'currprt$.out'
  547.  
  548.    select select()                && grab next available work area ...
  549.    
  550.    use currprt order currprt excl && open database called CURRPRT
  551.    zap                            && clean out old copy of this file
  552.    
  553.    append from currprt$.out type sdf
  554.                                   && import the data for manipulation
  555.    
  556.    seek "Print"
  557.    *-- This is setup to do an indexed search, since the printer information
  558.    *-- will not always be on the same line. If it were, we could issue a
  559.    *-- 'GO <n>' command, which would speed up the routine. Somewhere on
  560.    *-- line 8 to 12 (or record) is 'Print destination: <port/file>'. The
  561.    *-- seek looks for the first word. The command below trims out the
  562.    *-- first part of the line, and extra spaces as well. This will
  563.    *-- return the information after the colon.
  564.    cPort = upper(trim(right(currprt,60))) && always in upper case
  565.    
  566.    *-- clean up
  567.    use
  568.    
  569.    if len(trim(cDBF)) > 0
  570.       select (cDBF)
  571.    else
  572.       select 1
  573.    endif
  574.    
  575.    *-- erase this file
  576.    erase currprt$.out 
  577.    
  578.    *-- return safety and console to previous states ...
  579.    set safety &cSafety
  580.    set console &cConsole
  581.    
  582. RETURN cPort
  583. *-- EoF: CurrPort()
  584.  
  585. FUNCTION FileLock
  586. *-------------------------------------------------------------------------------
  587. *-- Programmer..: Miriam Liskin
  588. *-- Date........: 04/27/1992
  589. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book.
  590. *--               This routine modified by Ken Mayer to handle slightly
  591. *--               fancier processing ...
  592. *-- Written for.: dBASE IV, 1.1
  593. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows
  594. *--               and such.
  595. *-- Calls.......: CENTER               Procedure in PROC.PRG
  596. *--               SHADOW               Procedure in PROC.PRG
  597. *-- Called by...: Any
  598. *-- Usage.......: FileLock("<cColor>") 
  599. *-- Example.....: if FileLock("&cl_Wind1")
  600. *--                  *-- pack/reindex/whatever you need to do to database
  601. *--               else
  602. *--                  *-- do whatever processing necessary if file not
  603. *--                  *-- available for locking at this time
  604. *--               endif
  605. *-- Returns.....: Logical (.t./.f.)
  606. *-- Parameters..: cColor = Color combination for window ...
  607. *-------------------------------------------------------------------------------
  608.  
  609.     parameters cColor
  610.     private nCount,lLock,x,cCurNorm,cCurBox,cTempCol
  611.     
  612.     *-- deal with dBASE IV standard errors -- we don't want program bombing
  613.     on error ??
  614.     
  615.     *-- deal with screen stuff ...
  616.     *-- get it started ...
  617.     nCount = 1   && start at 1
  618.     lLock = .t.  && assume true
  619.     
  620.     *-- try 100 times
  621.     do while nCount <= 100 .and. .not. flock() .and. inkey() = 0
  622.         nCount = nCount + 1
  623.     enddo
  624.     
  625.     *-- if we can't lock the file, let the user know ...
  626.     if .not. flock()
  627.         lLock = .f.
  628.         save screen to sLock
  629.         *-- save colors
  630.         cCurNorm = colorof("NORMAL")
  631.         cCurBox  = colorof("BOX")
  632.         *-- set new colors
  633.         cTempCol = colorbrk(cColor,1)
  634.         set color of normal to &cTempCol
  635.         cTempCol = colorbrk(cColor,3)
  636.         set color of box to &cTempCol
  637.         *-- define window, display message
  638.         activate screen
  639.         define window wLock from 10,15 to 18,65 double
  640.         do shadow with 10,15,18,65
  641.         activate window sLock
  642.         do center with 1,50,"","The file cannot be locked at this time"
  643.         do center with 2,50,"","Please try again."
  644.         x = inkey(0)
  645.         *-- cleanup
  646.         deactivate window wLock
  647.         release window wLock
  648.         restore screen from sLock
  649.         release screen sLock
  650.         *-- reset colors
  651.         set color of normal to &cCurNorm
  652.         set color of box    to &cCurBox
  653.     endif
  654.     
  655.     *-- clean up screen, etc.
  656.     on error
  657.     
  658. RETURN lLock
  659. *-- EoF: FileLock()
  660.  
  661. FUNCTION RecLock
  662. *-------------------------------------------------------------------------------
  663. *-- Programmer..: Miriam Liskin
  664. *-- Date........: 04/27/1992
  665. *-- Notes.......: Taken from Miriam Liskin's dBASE IV, 1.1 Programming Book.
  666. *--               This function attempts to lock current record in active
  667. *--               database. 
  668. *-- Written for.: dBASE IV, 1.1
  669. *-- Rev. History: 04/27/1992 -- Modified by Ken Mayer to give cleaner windows
  670. *--               and such.
  671. *-- Calls.......: CENTER               Procedure in PROC.PRG
  672. *--               SHADOW               Procedure in PROC.PRG
  673. *-- Called by...: Any
  674. *-- Usage.......: RecLock("<cColor>") 
  675. *-- Example.....: if RecLock("&cl_Wind1")
  676. *--                  *-- process record
  677. *--               else
  678. *--                  *-- return to menu, or whatever processing your routine
  679. *--                  *-- does at this point
  680. *--               endif
  681. *-- Returns.....: Logical (.t./.f.)
  682. *-- Parameters..: cColor = Color combination for window ...
  683. *-------------------------------------------------------------------------------
  684.  
  685.     parameters cColor
  686.     private nCount, lLock, cRetry, cCurNorm, cCurBox, cTempCol
  687.     
  688.     *-- deal with dBASE IV standard errors -- we don't want program bombing
  689.     on error ??
  690.     
  691.     *-- deal with screen
  692.     *-- start trying -- we will give the user the option to exit -- each time
  693.     *-- they unsuccessfully lock the record.
  694.     lLock = .t.   && assume true
  695.     do while .t.  && main loop
  696.         nCount = 1 && initialize each time we try ...
  697.         
  698.         *-- effectively a time-delay loop ...
  699.         do while nCount <= 100 .and. .not. rLock() .and. inkey() = 0
  700.             nCount = nCount + 1
  701.         enddo
  702.         
  703.         *-- if we CAN lock it, we're done, get outta here ...
  704.         if rlock()
  705.             lLock = .t.
  706.             exit
  707.         
  708.         else
  709.         
  710.             *-- otherwise, let the user know we couldn't do it, and ask if
  711.             *-- they want to try again ...
  712.             save screen to sLock
  713.             *-- save colors
  714.             cCurNorm = colorof("NORMAL")
  715.             cCurBox  = colorof("BOX")
  716.             *-- set new colors
  717.             cTempCol = colorbrk(cColor,1)
  718.             set color of normal to &cTempCol
  719.             cTempCol = colorbrk(cColor,3)
  720.             set color of box to &cTempCol
  721.             *-- define window ...
  722.             activate screen
  723.             define window wLock from 10,15 to 18,65 double
  724.             do shadow with 10,15,18,65
  725.             activate window wLock
  726.             lLock = .f.
  727.             cRetry = 'N'
  728.             @1,3 say "This record is being updated at another"
  729.             @2,3 say "workstation. You can try again now,"
  730.             @3,3 say "to access the record, or return to it"
  731.             @4,3 say "later."
  732.             @6,3 say "Do you want to try again now? " get cRetry;
  733.                 picture "!";
  734.                 valid required cRetry $ "YN";
  735.                 error chr(7)+"Enter 'Y' or 'N'"
  736.             read
  737.             *-- cleanup
  738.             deactivate window wLock
  739.             release window wLock
  740.             restore screen from sLock
  741.             release screen sLock
  742.             *-- reset colors
  743.             set color of normal to &cCurNorm
  744.             set color of box    to &cCurBox
  745.             
  746.             if cRetry = "N"
  747.                 exit
  748.             endif  && cRetry = "N"
  749.             
  750.         endif  && rLock()
  751.         
  752.     enddo  && end of main loop
  753.     
  754.     *-- cleanup
  755.     on error
  756.  
  757. RETURN lLock
  758. *-- EoF: RecLock()
  759.  
  760. PROCEDURE DosShell
  761. *-------------------------------------------------------------------------------
  762. *-- Programmer..: Bowen Moursund
  763. *-- Date........: 06-10-1992
  764. *-- Notes.......: Swaps out dBASE from memory, loads a DOS shell
  765. *-- Written for.: dBASE IV v1.5
  766. *-- Rev. History: none
  767. *-- Calls.......: None
  768. *-- Called by...: Any
  769. *-- Usage.......: do DosShell with <cAppName>
  770. *-- Example.....: do DosShell with "MyApp"
  771. *-- Parameters..: cAppName - the name of the application
  772. *-------------------------------------------------------------------------------
  773.  
  774.     parameter cAppName
  775.      private cDir, lCursOff, cBatFile, nFH, nResult
  776.     cAppName = iif(pcount() = 0, "the application", cAppName)
  777.     private all
  778.     cDir = set("directory")
  779.     lCursOff = ( set("cursor") = "OFF" )
  780.     cBatFile = tempname("bat") + ".bat"
  781.     nFH = fcreate(cBatFile)
  782.     if nFH > 0
  783.         nBytes = fputs(nFH,"echo off")
  784.         nBytes = fputs(nFH,"cls")
  785.         nBytes = fputs(nFH,"echo " + chr(255))  && echo a blank line
  786.         nBytes = fputs(nFH,"echo NOTE: Enter EXIT to resume " + cAppName + ".")
  787.         nBytes = fwrite(nFH,getenv("comspec"))
  788.         null = fclose(nFH)
  789.         set cursor on
  790.         nResult = run(.f., cBatFile, .t.)
  791.         if nResult # 0
  792.             run &cBatFile
  793.         endif
  794.         erase (cBatFile)
  795.     else
  796.         cComSpec = getenv("comspec")
  797.         set cursor on
  798.         run &cComSpec.
  799.     endif
  800.     if lCursOff
  801.         set cursor off
  802.     endif
  803.     set directory to &cDir
  804.  
  805. RETURN
  806. *-- EoP: DosShell
  807.  
  808. FUNCTION IsDisk
  809. *-------------------------------------------------------------------------------
  810. *-- Programmer...: Ken Mayer (KENMAYER)
  811. *-- Date.........: 07/13/1992
  812. *-- Notes........: This routine is useful to check a drive for a valid disk in
  813. *--                in it (Valid means it is in the drive, with the door closed,
  814. *--                and is formatted ...). 
  815. *--                ***********************
  816. *--                ** REQUIRES DISK.BIN **
  817. *--                ***********************
  818. *-- Written for.: dBASE IV, 1.5
  819. *-- Rev. History: None
  820. *-- Called by...: None
  821. *-- Calls.......: CENTER               Procedure in PROC.PRG
  822. *--               SHADOW               Procedure in PROC.PRG
  823. *-- Usage.......: IsDisk(<cDrive>,<cMessCol>,<cErrCol>)
  824. *-- Example.....: IsDisk("cDrive","rg+/gb","rg+/r")
  825. *-- Returns.....: Logical
  826. *-- Parameters..: cDrive   = drive name -- single letter, no colon (i.e., "A")
  827. *--               cMessCol = color for message bonX
  828. *--               cErrCol  = color for error message
  829. *-------------------------------------------------------------------------------
  830.  
  831.     parameters cDrive, cMessCol, cErrCol
  832.  
  833.     private nX, cDrive2
  834.     
  835.     *-- deal with message window
  836.     save screen to sDisk
  837.     activate screen
  838.     define window wDisk from 9,15 to 12,65 double color &cMessCol,,&cMessCol
  839.     do shadow with 9,15,12,65
  840.     activate window wDisk
  841.     *-- display message ...
  842.     do center with 0,50,"&cMessCol",;
  843.         "Place disk in drive "+cDrive+": and close drive door."
  844.     do center with 1,50,"&cMessCol",;
  845.         "Press any key when ready ..."
  846.     set cursor off
  847.     nX=inkey(0)
  848.     set cursor on
  849.     deactivate window wDisk
  850.     restore screen from sDisk
  851.  
  852.     *-- check for a valid drive. This uses the BIN file: DISK.BIN to do so.
  853.     load disk                 && load the BIN file
  854.     cDrive2 = cDrive          && save the current setting in case there's a prob.
  855.     call disk with cDrive2    && check to see if it's valid
  856.     activate screen
  857.     define window wDisk from 7,10 to 14,70 double color &cErrCol,,&cErrCol
  858.     do while cDrive2 = 'X'    && perform loop if value of cDrive2 is 'X' (error)
  859.         do shadow with 7,10,14,70
  860.         activate window wDisk
  861.         do center with 0,60,"&cErrCol",;
  862.             "** DRIVE ERROR **"
  863.         do center with 2,60,"&cErrCol",;
  864.             "Check to make sure a valid (formatted) disk is in drive,"
  865.         do center with 3,60,"&cErrCol",;
  866.             "and that the drive door is closed properly."
  867.         do center with 5,60,"&cErrCol",;
  868.             "Press <Esc> to exit, any other key to continue ..."
  869.         set cursor off
  870.         nX=inkey(0)
  871.         set cursor on
  872.         deactivate window wDisk
  873.         restore screen from sDisk
  874.         if nX = 27                 && user pressed <Esc>
  875.             release module disk
  876.             release window wDisk
  877.             release screen sDisk
  878.             RETURN .F.
  879.         endif
  880.         cDrive2 = cDrive          && reset cDrive2 from original
  881.         call disk with cDrive2    && check for validity again ...
  882.     enddo
  883.  
  884.     *-- cleanup
  885.     release module Disk          && remove module from RAM so we can continue
  886.     restore screen from sDisk
  887.     release screen sDisk
  888.     release window wDisk
  889.  
  890. RETURN .t.
  891. *-- EoF: IsDisk()
  892.  
  893. *-------------------------------------------------------------------------------
  894. *-- The following are here as a courtesy ...
  895. *-------------------------------------------------------------------------------
  896.  
  897. FUNCTION AtCount
  898. *-------------------------------------------------------------------------------
  899. *-- Programmer..: Jay Parsons (JPARSONS)
  900. *-- Date........: 03/01/92
  901. *-- Notes.......: returns the number of times FindString is found in Bigstring
  902. *-- Written for.: dBASE IV
  903. *-- Rev. History: None
  904. *-- Calls.......: None
  905. *-- Called by...: Any
  906. *-- Usage.......: AtCount("<cFindStr>","<cBigStr>")
  907. *-- Example.....: ? AtCount("Test","This is a Test string, with Test data")
  908. *-- Returns.....: Numeric value
  909. *-- Parameters..: cFindStr = string to find in cBigStr
  910. *--               cBigStr  = string to look in
  911. *-------------------------------------------------------------------------------
  912.  
  913.     parameters cFindstr, cBigstr
  914.     private cTarget, nCount
  915.     
  916.     cTarget = cBigstr
  917.     nCount = 0
  918.     
  919.     do while .t.
  920.         if at( cFindStr,cTarget ) > 0
  921.             nCount = nCount + 1
  922.             cTarget = substr( cTarget, at( cFindstr, cTarget ) + 1 )
  923.         else
  924.          exit
  925.         endif
  926.     enddo
  927.     
  928. RETURN nCount
  929. *-- EoF: AtCount()
  930.     
  931. FUNCTION Dec2Hex
  932. *-------------------------------------------------------------------------------
  933. *-- Programmer..: Jay Parsons (JPARSONS)
  934. *-- Date........: 03/01/1992
  935. *-- Notes.......: Converts an integral number ( in decimal notation)
  936. *--               to a hexadecimal string
  937. *-- Written for.: dBASE IV, 1.1
  938. *-- Rev. History: None
  939. *-- Calls.......: None
  940. *-- Called by...: Any
  941. *-- Usage.......: Dec2Hex(<nDecimal>)
  942. *-- Example.....: ? Dec2Hex( 118 )
  943. *-- Returns.....: Character = Hexadecimal equivalent ( "F6" in example )
  944. *-- Parameters..: nDecimal = number to convert
  945. *-------------------------------------------------------------------------------
  946.     
  947.     parameters nDecimal
  948.     private nD, cH
  949.     nD = int( nDecimal )
  950.     cH= ""
  951.     do while nD > 0
  952.       cH = substr( "0123456789ABCDEF", mod( nD, 16 ) + 1 , 1 ) + cH
  953.       nD = int( nD / 16 )
  954.     enddo
  955.     
  956. RETURN iif( "" = cH, "0", cH )
  957. *-- Eof: Dec2Hex()
  958.  
  959. FUNCTION StrPBrk
  960. *-------------------------------------------------------------------------------
  961. *-- Programmer..: Jay Parsons (JPARSONS)
  962. *-- Date........: 03/01/92
  963. *-- Notes.......: Search string for first occurrence of any of the
  964. *--               characters in charset.  Returns its position as
  965. *--               with at().  Contrary to ANSI.C definition, returns
  966. *--               0 if none of characters is found.
  967. *-- Written for.: dBASE IV
  968. *-- Rev. History: None
  969. *-- Calls.......: None
  970. *-- Called by...: Any
  971. *-- Usage.......: StrPBrk("<cCharSet>","<cBigStr>")
  972. *-- Example.....: ? StrPBrk("Tt","This is a Test string, with Test data")
  973. *-- Returns.....: Numeric value
  974. *-- Parameters..: cCharSet = characters to look for in cBigStr
  975. *--               cBigStr  = string to look in
  976. *-------------------------------------------------------------------------------
  977.  
  978.     parameters cCharset, cBigstring
  979.     private nPos, nLooklen
  980.     nPos = 0
  981.     nLooklen = len( cBigstring )
  982.     do while nPos < nLooklen
  983.       nPos = nPos + 1
  984.         if at( substr( cBigstring, nPos, 1 ), cCharset ) > 0
  985.          exit
  986.        endif
  987.     enddo
  988.     
  989. RETURN iif(nPos=nLookLen,0,nPos)
  990. *-- EoF: StrPBrk()
  991.  
  992. *-------------------------------------------------------------------------------
  993. *-- EoP: MISC.PRG
  994. *-------------------------------------------------------------------------------
  995.